Usenet 1993 July/InfoMagic USENET CD-ROM July 1993.ISO/sources/unix/volume10/comobj.lisp/part03

Internet Message Format | 1987-07-30 | 49.2 KB

Path: uunet!rs
From: [e-mail] (Rich Salz)
Newsgroups: comp.sources.unix
Subject: v10i077:  Common Objects, Common Loops, Common Lisp, Part03/13
Message-ID: <[e-mail]>
Date: 31 Jul 87 19:58:53 GMT
Organization: UUNET Communications Services, Arlington, VA
Lines: 1464
Approved: [e-mail]

Submitted-by: Roy D'Souza <[e-mail]>
Posting-number: Volume 10, Issue 77
Archive-name: comobj.lisp/Part03

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#        "End of archive 3 (of 13)."
# Contents:  co-meta.l defsys.l fixup.l high.l
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'co-meta.l' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'co-meta.l'\"
else
echo shar: Extracting \"'co-meta.l'\" \(12006 characters\)
sed "s/^X//" >'co-meta.l' <<'END_OF_FILE'
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; File:         co-meta.l
X; RCS:          $Revision: 1.1 $
X; SCCS:         %A% %G% %U%
X; Description:  Metaclass for CommonObjects
X; Author:       James Kempf
X; Created:      March 10, 1987
X; Modified:     March 10, 1987  13:30:58 (Roy D'Souza)
X; Language:     Lisp
X; Package:      COMMON-OBJECTS
X; Status:       Distribution
X;
X; (c) Copyright 1987, HP Labs, all rights reserved.
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; Copyright (c) 1987 Hewlett-Packard Corporation. All rights reserved.
X;
X; Use and copying of this software and preparation of derivative works based
X; upon this software are permitted.  Any distribution of this software or
X; derivative works must comply with all applicable United States export
X; control laws.
X;
X; This software is made available AS IS, and Hewlett-Packard Corporation makes
X; no warranty about the software, its performance or its conformity to any
X; specification.
X;
X; Suggestions, comments and requests for improvement may be mailed to
X; [e-mail]
X
X;;;-*-Mode:LISP; Package:(CO (PCL LISP)); Base:10; Syntax: Common-lisp-*-
X;;;
X;;; *************************************************************************
X;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
X;;;
X;;; Use and copying of this software and preparation of derivative works
X;;; based upon this software are permitted.  Any distribution of this
X;;; software or derivative works must comply with all applicable United
X;;; States export control laws.
X;;;
X;;; This software is made available AS IS, and Xerox Corporation makes no
X;;; warranty about the software, its performance or its conformity to any
X;;; specification.
X;;;
X;;; Any person obtaining a copy of this software is requested to send their
X;;; name and post office or electronic mail address to:
X;;;   CommonLoops Coordinator
X;;;   Xerox Artifical Intelligence Systems
X;;;   2400 Hanover St.
X;;;   Palo Alto, CA 94303
X;;; (or send Arpanet mail to [e-mail])
X;;;
X;;; Suggestions, comments and requests for improvements are also welcome.
X;;; *************************************************************************
X
X(in-package 'common-objects :nicknames '(co) :use '(lisp pcl walker))
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X;    CommonObjects Class Ndefstruct
X;
X;  Instances are represented as trees of their parent instances just like
X;  in the original CommonObjects implementation except that we do not make
X;  make the single inheritance optimization of in-lining the first parent.
X;  The first slot of every instance is the class object.
X;  The second slot of every instance is named .SELF. and is a pointer to
X;  the acutal object. Then come slots for each of the parent class instances,
X;  then the slots for this class.
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X(ndefstruct (common-objects-class
X          (:class class)
X          (:include (essential-class))
X          (:conc-name class-)
X            )
X
X  (instance-size 1)             ;The total number of slots every instance
X                ;of this class must have.  This includes
X                ;one slot for the pointer to outer self and
X                ;one slot for each of the parent instances.
X
X  (local-super-slot-names ())   ;A list of the names of the slots used to
X                ;store the parent instances.  This list
X                ;exactly parallels the local-supers as
X                ;stored in class-local-supers.
X
X  (slots ())            ;The slots required by CommonLoops.
X
X  (user-visible-slots ())    ;Instance variable names.
X
X  (children ())            ;Children of this guy. Not currently used.
X
X  (init-keywords                ;Initialization keywords
X    ()
X  )
X  (init-keywords-check T)       ;Whether to check the initialization
X                ;keywords
X) ;end ndefstruct for common-objects-class
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;  Establishment of the CommonObjects MetaClass
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X(eval-when (load)
X (define-meta-class common-objects-class
X   (lambda (x) (%instance-ref x $CLASS-OBJECT-INDEX))
X))
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;  CommonObjects MetaClass Protocol
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;add-class-Add a CommonObjects class. Part of the metaclass protocol.
X
X(defmeth add-class ((class common-objects-class)
X            new-local-supers
X            new-local-slots
X            extra
X                   )
X
X  (let
X    (
X      (local-super-slot-names
X      (mapcar #'(lambda (nls) (local-super-slot-name (class-name nls)))
X          new-local-supers
X          )
X       )
X     )
X
X    (setf (class-local-super-slot-names class) local-super-slot-names)
X
X    (setf (class-user-visible-slots class) new-local-slots)
X
X    (setq new-local-slots
X          (mapcar #'(lambda (x) (make-slotd class :name x))
X                    (append local-super-slot-names
X                        new-local-slots)
X          )
X    )
X
X    (setf (class-instance-size class) (length new-local-slots))
X
X    (run-super)
X
X  ) ;let
X
X) ;end add-class
X
X;;class-slots-Return the slot names for the parents
X
X(defmeth class-slots ((class common-objects-class))
X
X  (class-local-slots class)
X
X) ;end class-slots
X
X;;has-slot-p-Return T if class has user visible slot symbol
X
X(defmeth has-slot-p ((class common-objects-class) symbol)
X
X  (let
X    (
X      (bool NIL)
X    )
X
X    (dolist (slotd (class-user-visible-slots class))
X      (when  (equal symbol (slot-name-from-slotd slotd))
X    (setf bool T)
X        (return)
X      )
X    )
X    bool
X
X  ) ;end let
X
X) ;end has-slot-p
X
X;;init-keywords-Return the initialization keywords
X
X(defmeth init-keywords ((class common-objects-class))
X
X  (class-init-keywords class)
X
X) ;init-keywords
X
X;;class-local-super-names-Return the names of the local supers for
X;;  this class.
X
X(defmeth class-local-super-names ((class common-objects-class))
X
X  (mapcar #'(lambda (x) (class-name x)) (class-local-supers class))
X
X) ;end class-local-super-names
X
X;;compute-class-precedence-list-Calculate class precedence.
X;;  CommonObjects classes don't inherit in the CommonLoops sense.
X;;  Tell CommonLoops that they only inherit from themselves,
X;;  the class COMMON-OBJECTS-CLASS itself which they need for
X;;  GET-SLOT-USING-CLASS and PUT-SLOT-USING-CLASS and default printing
X;;  to work right.
X
X(defmeth compute-class-precedence-list ((class common-objects-class))
X
X  (list class (class-named 'common-objects-class) (class-named 'object))
X
X) ;end compute-class-precedence-list
X
X;;method-alist-Return the a-list of names v.s. method objects. Only
X;;  methods which are CommonObjects methods are returned. This
X;;  is to accomodate system generated methods, like TYPE-OF, which
X;;  should not be identified as methods on CommonObjects instances.
X;;  This routine is primarily used in parsing.
X
X(defmeth method-alist ((class common-objects-class))
X  (declare (special *universal-methods*))
X
X  (let
X    (
X      (alist NIL)
X    )
X
X    ;;First get the direct methods
X
X    (dolist (methobj (class-direct-methods class))
X
X        (if (eq (class-name (class-of methobj)) 'common-objects-method)
X
X          (push
X        (list (unkeyword-standin (method-name methobj)) methobj)
X        alist
X      )
X        ) ;if
X    )
X
X    ;;Now check if any of the universal methods need to be added
X
X    (dolist (univmeth *universal-methods*)
X
X      (if (not (assoc univmeth alist))
X        (push
X          (list
X        univmeth
X        (find-method
X          (discriminator-named (keyword-standin univmeth))
X              '(common-objects-class)
X          NIL
X          T
X            )
X          )
X          alist
X        )
X
X      ) ;if
X
X    ) ;dolist
X
X    alist
X
X  ) ;end let
X
X) ;end method-alist
X
X;;check-init-keywords-Check if the initialization keywords are
X;;  correct
X
X(defmeth check-init-keywords ((class common-objects-class) keylist)
X
X  (let
X    (
X      (legalkeys (class-init-keywords class))
X    )
X
X    (do
X      (
X        (key (car keylist) (cddr key) )
X      )
X      ( (null key) )
X
X      (if (not (and (keywordp (car key)) (>= (length key) 2)))
X        (error "MAKE-INSTANCE: For type ~S, keylist must have alternating keys and values. List:~S~%"
X         (class-name class) (car keylist)
X        )
X      )
X
X      (when (not (member (car key) legalkeys))
X        (error "MAKE-INSTANCE: For type ~S, ~S is not a legal initialization keyword.~%"
X         (class-name class) (car key)
X        )
X      )
X    ) ;dolist
X
X  ) ;let
X
X) ;end check-init-keywords
X
X;;optimize-get-slot-Optimize a get slot by returning
X;;  the right code. CommonObjects instances are statically
X;;  allocated, so "hard" indicies can be used for them.
X;;  Stolen from the protocol for BASIC-CLASS.
X
X;(defmeth optimize-get-slot ((method common-objects-method)
X;                     (class common-objects-class)
X;                     form)
X;  (declare (ignore method)) ; rds 3/9
X(defmeth optimize-get-slot ((class common-objects-class) form)
X    `(%instance-ref ,(second form) ,(slot-index class (second (third form))))
X
X
X
X) ;end optimize-get-slot
X
X;;pcl::optimize-setf-of-get-slot-Optimize a setf of a slot
X;;  by returning the right code. Again, "hard" indicies
X;;  can be used since in-line allocation is the rule.
X;;  Stolen from the protocol for BASIC-CLASS.
X
X;(defmeth pcl::optimize-setf-of-get-slot ((method common-objects-method)
X;                         (class common-objects-class)
X;                         form)
X;  (declare (ignore method))
X(defmeth pcl::optimize-setf-of-get-slot ((class common-objects-class)
X                                         form)
X    `(setf
X      (%instance-ref , (nth 1 form) ,(slot-index class (second (nth 2 form))))
X           ,(nth 3 form)
X     )
X
X) ;end optimize-setf-of-get-slot
X
X;;slot-index-Calculate the slot index for the indicated slot
X
X(defmeth slot-index ((class common-objects-class) slotname)
X
X  ;;Treat .SELF. as a special case
X
X  (if (eq slotname '.self.)
X    $SELF-INDEX
X
X    (calculate-slot-index
X      slotname
X      (class-local-super-slot-names class)
X      (class-user-visible-slots class)
X    )
X
X  ) ;if
X
X) ;end slot-index
X
X;;get-slot-using-class-Generic version for all CommonObjects classes.
X;;  Normally, this will be optimized out by the optimization method
X;;  but just in case.
X
X(defmeth get-slot-using-class ((class common-objects-class) object slot-name)
X
X  (%instance-ref object (slot-index class slot-name))
X
X) ;get-slot-using-class
X
X;;put-slot-using-class-Generic version for all CommonObjects classes.
X;;  A bug in the default code-walker makes this necessary, although
X;;  ultimately a custom walking function for CommonObjects methods
X;;  might make the optimization work. Note that the code walker
X;;  bug is fixed in the specialized walker method WALK-METHOD-BODY-INTERNAL
X;;  for CommonObjects methods.
X
X(defmeth pcl::put-slot-using-class
X  ((class common-objects-class) object slot-name new-value)
X
X  (setf
X    (%instance-ref object (slot-index class slot-name) )
X    new-value
X  )
X
X) ;put-slot-using-class
X
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;  CommonObjects MetaClass Utility Functions
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;defined-classes-List the defined CommonObjects classes
X
X(defun defined-classes ()
X
X  (let
X    (
X      (defined-types NIL)
X      (class (class-named 'common-objects-class))
X    )
X
X    (maphash
X    #'(lambda (key val)
X        (when (and val (eq (class-of val) class))
X          (setf defined-types (cons key defined-types))
X            )
X      )
X          pcl::*class-name-hash-table*
X    )
X    defined-types
X  )
X) ;end defined-classes
X
X;;slot-name-from-slotd-Return the name of the slot, given the SLOTD.
X
X(defun slot-name-from-slotd (slotd)
X  slotd
X
X) ;slot-name-from-slotd
X
X;;method-name-Return the method name, given the method object
X
X(defun method-name (methobj)
X
X  (discriminator-name (method-discriminator methobj))
X)
X
END_OF_FILE
if test 12006 -ne `wc -c <'co-meta.l'`; then
    echo shar: \"'co-meta.l'\" unpacked with wrong size!
fi
# end of 'co-meta.l'
fi
if test -f 'defsys.l' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'defsys.l'\"
else
echo shar: Extracting \"'defsys.l'\" \(11775 characters\)
sed "s/^X//" >'defsys.l' <<'END_OF_FILE'
X;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
X;;;
X;;; *************************************************************************
X;;; Copyright (c) 1985, 1986, 1987 Xerox Corporation.  All rights reserved.
X;;;
X;;; Use and copying of this software and preparation of derivative works
X;;; based upon this software are permitted.  Any distribution of this
X;;; software or derivative works must comply with all applicable United
X;;; States export control laws.
X;;;
X;;; This software is made available AS IS, and Xerox Corporation makes no
X;;; warranty about the software, its performance or its conformity to any
X;;; specification.
X;;;
X;;; Any person obtaining a copy of this software is requested to send their
X;;; name and post office or electronic mail address to:
X;;;   CommonLoops Coordinator
X;;;   Xerox Artifical Intelligence Systems
X;;;   2400 Hanover St.
X;;;   Palo Alto, CA 94303
X;;; (or send Arpanet mail to [e-mail])
X;;;
X;;; Suggestions, comments and requests for improvements are also welcome.
X;;; *************************************************************************
X;;;
X;;; Some support stuff for compiling and loading PCL.  It would be nice if
X;;; there was some portable make-system we could all agree to share for a
X;;; while.  At least until people really get databases and stuff.
X;;;
X;;; *** To install PCL at a new site, read the directions above the    ***
X;;; *** second and third defvars in this file (down about 10 lines).  ***
X;;;
X
X(in-package 'pcl :use (list (or (find-package 'walker)
X                (make-package 'walker :use '(lisp)))
X                'lisp))
X
X(defvar *pcl-system-date* "2/24/87")
X
X;;;
X;;; Some CommonLisps have more symbols in the Lisp package than the ones that
X;;; are explicitly specified in CLtL.  This causes trouble. Any Lisp that has
X;;; extra symbols in the Lisp package should shadow those symbols in the PCL
X;;; package.
X;;;
X#+TI
X(shadow '(string-append once-only destructuring-bind
X      memq assq delq neq ignore true false
X      without-interrupts
X      defmethod)
X    'pcl)
X#+Spice
X(shadow '(memq assq delq) (find-package 'pcl))
X#+Symbolics
X(shadow '(ignore) (find-package 'pcl))
X
X;;;
X;;; When installing PCL at your site, edit this defvar to give the directory
X;;; in which the PCL files are stored.  The values given below are EXAMPLES
X;;; of correct values for *pcl-pathname-defaults*.
X;;;
X(defvar *pcl-pathname-defaults*
X    #+Symbolics                (pathname "avalon:>Gregor>pcl>")
X    #+SUN                      (pathname "/usr/yak/gregor/pcl/")
X    #+ExCL                     (pathname "/usr/yak/gregor/pcl/")
X    #+KCL                      (pathname "/user/isl/gregor/pcl/")
X    #+(and DEC common vax VMS) (pathname "[gregor]")
X    #+Spice                   (pathname "pcl:")
X    #+HP                  (pathname "/net/hplfs2/users/kempf/public/pcl/")
X    #+Xerox                    (pathname "{phylum}<pcl>")
X    )
X
X;;;
X;;; When you get a copy of PCL (by tape or by FTP), the sources files will
X;;; have extensions of ".l" specifically, this file will be named defsys.l.
X;;; The preferred way to install pcl is to rename these files to have the
X;;; extension which your lisp likes to use for its files.  Alternately, it
X;;; is possible not to rename the files.  If the files are not renamed to
X;;; the proper convention, the second line of the following defvar should
X;;; be changed to:
X;;;     (let ((files-renamed-p nil)
X;;;
X;;; Note: Something people installing PCL on a machine running Unix
X;;;       might find useful.  If you want to change the extensions
X;;;       of the source files from ".l" to ".lsp", *all* you have to
X;;;       do is the following:
X;;;
X;;;       % foreach i (*.l)
X;;;       ? mv $i $i:r.lsp
X;;;       ? end
X;;;       %
X;;;
X;;;       I am sure that a lot of people already know that, and some
X;;;       Unix hackers may say, "jeez who doesn't know that".  Those
X;;;       same Unix hackers are invited to fix mv so that I can type
X;;;       "mv *.l *.lsp".
X;;;
X(defvar *pathname-extensions*
X    (let ((files-renamed-p t)
X          (proper-extensions
X        (car '(#+Symbolics           ("lisp"  . "bin")
X               #+(and dec common)    ("LSP"   . "FAS")
X               #+KCL                 ("lsp"   . "o")
X               #+Xerox               ("lisp"  . "dfasl")
X               #+(and Lucid MC68000) ("lisp"  . "lbin")
X               #+(and Lucid VAX VMS) ("lisp"  . "vbin")
X               #+excl                ("cl"    . "fasl")
X               #+Spice               ("slisp" . "sfasl")
X               #+HP                  ("l"     . "b")
X               #+TI                  ("lisp"  . "xfasl")
X               ))))
X      (cond ((null proper-extensions) '("l" . "lbin"))
X        ((null files-renamed-p) (cons "l" (cdr proper-extensions)))
X        (t proper-extensions))))
X
X
X
X;;;
X;;; *PCL-FILES* is a kind of "defsystem" for pcl.  A new port of pcl should
X;;; add an entry for that port's xxx-low file.
X;;;
X(defvar *pcl-files*
X  (let ((xxx-low (or #+Symbolics '3600-low
X             #+Lucid     'lucid-low
X             #+Xerox     'Xerox-low
X             #+TI        'ti-low
X             #+(and dec common) 'vaxl-low
X             #+KCL       'kcl-low
X             #+excl      'excl-low
X             #+Spice     'spice-low
X             #+HP        'hp-low
X             nil)))
X    ;; file         load           compile         files which force
X    ;;              environment    environment     recompilations of
X    ;;                                             this file
X    `(
X      #+Symbolics
X      (rel-7-patches nil            nil                    nil)
X      #+Symbolics
X      (walk         (rel-7-patches) (rel-7-patches)        nil)
X      #-Symbolics
X      (walk         nil             nil                    ())
X      (macros       (walk)          (walk macros)          ())
X      (low          (walk)          (macros)               (macros))
X      (,xxx-low     (low)           (macros low)           ())
X      (braid        t               ((braid :source))      (low ,xxx-low))
X      (class-slots  t               (braid)                (low ,xxx-low))
X      (defclass     t               (braid defclass)       (low ,xxx-low))
X      (class-prot   t               (braid
X                     defclass)             (low ,xxx-low))
X      (methods      t               (braid
X                     class-prot
X                     (methods :source)    ;Because Common Lisp
X                                ;makes it unlikely
X                                ;that any particular
X                                ;CommonLisp will do
X                                ;the right thing with
X                                ;a defsetf during
X                                ;a compile-file.
X                     )                  (low ,xxx-low))
X      (dfun-templ   t               (methods
X                      (dfun-templ :source)) (low ,xxx-low))
X      (fixup        t               (braid
X                     methods
X                     (fixup :source))   (low
X                             ,xxx-low
X                             braid
X                             class-slots
X                             defclass
X                             class-prot
X                             methods
X                             dfun-templ))
X      (high         (fixup)         ((high :source))    (low ,xxx-low walk))
X      (compat       (high)          (high))
X;     (meth-combi   (high)          (high)              )
X;     (meth-combs   (meth-combi)    (meth-combi)        (meth-combi))
X;     (trapd        (meth-combs)    (high)              )
X      )))
X
X(defun load-pcl (&optional (sources-p nil))
X  (load-system
X    (if sources-p :sources :load) *pcl-files* *pcl-pathname-defaults*)
X  (provide "pcl"))
X
X(defun compile-pcl (&optional (force-p nil))
X  (load-system (if force-p ':force ':compile) *pcl-files* *pcl-pathname-defaults*))
X
X  ;;
X;;;;;; load-system
X  ;;
X;;; Yet Another Sort Of General System Facility and friends.
X;;;
X
X(defstruct (module (:constructor make-module
X                 (name load-env comp-env recomp-reasons))
X           (:print-function
X             (lambda (m s d)
X               (declare (ignore d))
X               (format s
X                   "#<Module ~A L:~@A  C:~@A  R:~@A>"
X                   (module-name m)
X                   (module-load-env m)
X                   (module-comp-env m)
X                   (module-recomp-reasons m)))))
X  name
X  load-env
X  comp-env
X  recomp-reasons)
X
X(defun load-system (mode system *default-pathname-defaults*)
X  (#+Symbolics compiler:compiler-warnings-context-bind
X   #-Symbolics progn
X   (let ((loaded ())    ;A list of the modules loaded so far.
X     (compiled ())  ;A list of the modules we have compiled.
X     (modules ())   ;All the modules in the system.
X     (module-names ())
X     (*modules-to-source-load* ()))
X     (declare (special *modules-to-source-load*))
X     (labels
X       (
X       ;(load (x) x)
X       ;(compile-file (x) x)
X    (find-module (name)
X      (or (car (member name modules :key #'module-name))
X          (error "Can't find module of name ~S???" name)))
X    (needs-compiling-p (m)
X      (or (null (probe-file (make-binary-pathname (module-name m))))
X          (eq (module-recomp-reasons m) 't)
X          (dolist (r (module-recomp-reasons m))
X        (when (member (find-module r) compiled)
X          (return t)))
X          (> (file-write-date (make-source-pathname (module-name m)))
X         (file-write-date (make-binary-pathname (module-name m))))))
X    (compile-module (m)
X      (unless (member m compiled)
X        (assure-compile-time-env m)
X        (format t "~&Compiling ~A..." (module-name m))
X        (compile-file (make-source-pathname (module-name m)))
X        (push m compiled)))
X    (load-module (m &optional source-p)
X      (setq source-p (or (if (member m *modules-to-source-load*) t nil)
X                 source-p
X                 (eq mode :sources)))
X      (unless (dolist (l loaded)
X            (and (eq (car l) m)
X             (eq (cdr l) source-p)
X             (return t)))
X        (assure-load-time-env m)
X        (cond (source-p
X           (format t "~&Loading source of ~A..." (module-name m))
X           (load (make-source-pathname (module-name m))))
X          (t
X           (format t "~&Loading ~A..." (module-name m))
X           (load (make-binary-pathname (module-name m)))))
X        (push (cons m source-p) loaded)))
X    (assure-compile-time-env (m)
X      (let ((*modules-to-source-load*
X          (cons m *modules-to-source-load*)))
X        (declare (special *modules-to-source-load*))    ;Should not have to
X                        ;but...
X        (dolist (c (module-comp-env m))
X          (when (eq (cadr c) :source)
X        (push (find-module (car c)) *modules-to-source-load*)))
X        (dolist (c (module-comp-env m))
X          (load-module (find-module (car c))))))
X    (assure-load-time-env (m)
X      (dolist (l (module-load-env m))
X        (load-module (find-module l))))
X    )
X
X       ;; Start by converting the list representation of we got into
X       ;; modules.  At the same time, we convert the abbreviations
X       ;; for load-envs and comp envs to the unabbreviated internal
X       ;; representation.
X       (dolist (file system)
X     (let ((name (car file))
X           (load-env (cadr file))
X           (comp-env (caddr file))
X           (recomp-reasons (cadddr file)))
X       (push (make-module name
X                  (if (eq load-env 't)
X                  (reverse module-names)
X                  load-env)
X                  (mapcar #'(lambda (c)
X                      (if (listp c)
X                          c
X                          (list c :binary)))
X                      (if (eq comp-env 't)
X                      (reverse (cons name module-names))
X                      comp-env))
X                  recomp-reasons)
X         modules)
X       (push name module-names)))
X       (setq modules (nreverse modules))
X       (ecase mode
X     (:compile
X       (dolist (module modules)
X         (when (needs-compiling-p module)
X           (compile-module module))))
X     (:force
X       (dolist (module modules)
X         (compile-module module)))
X     (:load
X       (dolist (module modules)
X         (load-module module)))
X     (:sources
X       (dolist (module modules)
X         (load-module module t))))))))
X
X(defun make-source-pathname (name)
X  (make-pathname
X    :name #-VMS (string-downcase (string name))
X          #+VMS (string-downcase (substitute #\_ #\- (string name)))
X    :type (car *pathname-extensions*)
X    :defaults *default-pathname-defaults*))
X
X(defun make-binary-pathname (name)
X  (make-pathname
X    :name #-VMS (string-downcase (string name))
X          #+VMS (string-downcase (substitute #\_ #\- (string name)))
X    :type (cdr *pathname-extensions*)
X    :defaults *default-pathname-defaults*))
X
END_OF_FILE
if test 11775 -ne `wc -c <'defsys.l'`; then
    echo shar: \"'defsys.l'\" unpacked with wrong size!
fi
# end of 'defsys.l'
fi
if test -f 'fixup.l' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'fixup.l'\"
else
echo shar: Extracting \"'fixup.l'\" \(12761 characters\)
sed "s/^X//" >'fixup.l' <<'END_OF_FILE'
X;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp; Patch-File: Yes -*-
X;;;
X;;; *************************************************************************
X;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
X;;;
X;;; Use and copying of this software and preparation of derivative works
X;;; based upon this software are permitted.  Any distribution of this
X;;; software or derivative works must comply with all applicable United
X;;; States export control laws.
X;;;
X;;; This software is made available AS IS, and Xerox Corporation makes no
X;;; warranty about the software, its performance or its conformity to any
X;;; specification.
X;;;
X;;; Any person obtaining a copy of this software is requested to send their
X;;; name and post office or electronic mail address to:
X;;;   CommonLoops Coordinator
X;;;   Xerox Artifical Intelligence Systems
X;;;   2400 Hanover St.
X;;;   Palo Alto, CA 94303
X;;; (or send Arpanet mail to [e-mail])
X;;;
X;;; Suggestions, comments and requests for improvements are also welcome.
X;;; *************************************************************************
X;;;
X
X(in-package 'pcl)
X
X(eval-when (compile load eval)
X  (setq *real-methods-exist-p* nil)
X  (setf (symbol-function 'expand-defmeth)
X    (symbol-function 'real-expand-defmeth)))
X
X(eval-when (load)
X  (clrhash *discriminator-name-hash-table*)
X  (fix-early-defmeths)
X ;; This now happens at the end of loading HIGH to make it
X ;; possible to compile and load pcl in the same environment.
X ;(setq *error-when-defining-method-on-existing-function* t)
X  )
X
X(eval-when (compile load eval)
X  (setq *real-methods-exist-p* t))
X
X  ;;
X;;;;;; Pending defmeths which I couldn't do before.
X  ;;
X
X
X(eval-when (load eval)
X  (setf (discriminator-named 'print-instance) ())
X  (make-specializable 'print-instance :arglist '(instance stream depth)))
X
X(defmeth print-instance ((instance object) stream depth)
X  (let ((length (if (numberp *print-length*) (* *print-length* 2) nil)))
X    (format stream "#S(~S" (class-name (class-of instance)))
X    (iterate ((slot-or-value in (all-slots instance))
X          (slotp = t (not slotp)))
X      (when (numberp length)
X    (cond ((<= length 0) (format stream " ...") (return ()))
X          (t (decf length))))
X      (princ " " stream)
X      (let ((*print-level* (cond ((null *print-level*) ())
X                 (slotp 1)
X                 (t (- *print-level* depth)))))
X    (if (and *print-level* (<= *print-level* 0))
X        (princ "#" stream)
X        (prin1 slot-or-value stream))))
X    (princ ")" stream)))
X
X(defmeth print-instance ((class essential-class) stream depth)
X  (named-object-print-function class stream depth))
X
X
X(defmethod print-instance ((method essential-method) stream depth)
X  (ignore depth)
X  (printing-random-thing (method stream)
X    (let ((discriminator (method-discriminator method))
X      (class-name (capitalize-words (class-name (class-of method)))))
X      (format stream "~A ~S ~:S"
X          class-name
X          (and discriminator (discriminator-name discriminator))
X          (method-type-specifiers method)))))
X
X(defmethod print-instance ((method basic-method) stream depth)
X  (ignore depth)
X  (printing-random-thing (method stream)
X    (let ((discriminator (method-discriminator method))
X      (class-name (capitalize-words (class-name (class-of method)))))
X      (format stream "~A ~S ~:S"
X          class-name
X          (and discriminator (discriminator-name discriminator))
X          (unparse-type-specifiers method)))))
X
X(defmethod print-instance ((discriminator essential-discriminator) stream depth)
X  (named-object-print-function discriminator stream depth))
X
X(defmethod print-instance ((discriminator basic-discriminator) stream depth)
X  (named-object-print-function
X    discriminator stream depth (list (method-combination-type discriminator))))
X
X(eval-when (load)
X
X(define-meta-class essential-class (lambda (x) (%instance-ref x 0)))
X
X(defmeth class-slots ((class essential-class))
X  (ignore class)
X  ())
X
X(defmeth make-instance ((class essential-class))
X  (let ((primitive-instance
X      (%make-instance (class-named 'esfiers method)))))
X
X(defmethod print-instance ((mss))))))
X    (setf (%instance-ref primitive-instance 0) class)
X    primitive-instance))
X
X(defmeth get-slot-using-class ((class essential-class) object slot-name)
X  (let ((pos (position slot-name (class-slots class) :key #'slotd-name)))
X    (if pos
X    (%instance-ref object (1+ pos))
X    (slot-missing ;class
X      object slot-name))))
X
X(defmeth put-slot-using-class ((class essential-class)
X                   object
X                   slot-name
X                   new-value)
X  (let ((pos (position slot-name (class-slots class) :key #'slotd-name)))
X    (if pos
X    (setf (%instance-ref object (1+ pos)) new-value)
X    (slot-missing ;class
X              object slot-name))))
X
X(defmeth optimize-get-slot (class form)
X  (declare (ignore class))
X  form)
X
X(defmeth optimize-setf-of-get-slot (class form)
X  (declare (ignore class))
X  form)
X
X(defmeth make-slotd ((class essential-class) &rest keywords-and-options)
X  (ignore class)
X  (apply #'make-slotd--essential-class keywords-and-options))
X
X(defmeth add-named-class ((proto-class essential-class) name
X              local-supers
X              local-slot-slotds
X              extra)
X  ;; First find out if there is already a class with this name.
X  ;; If there is, call class-for-redefinition to get the class
X  ;; object to use for the new definition.  If there is no exisiting
X  ;; class we just make a new instance.
X  (let* ((existing (class-named name t))
X     (class (if existing
X            (class-for-redefinition existing proto-class name
X                        local-supers local-slot-slotds
X                        extra)
X            (make (class-of proto-class)))))
X
X    (setq local-supers
X      (mapcar
X        #'(lambda (ls)
X        (or (class-named ls t)
X            (error "~S was specified as the name of a local-super~%~
X                            for the class named ~S.  But there is no class~%~
X                            class named ~S." ls name ls)))
X        local-supers))
X
X    (setf (class-name class) name)
X;   (setf (class-ds-options class) extra)    ;This is NOT part of the
X;                        ;standard protocol.
X
X    (add-class class local-supers local-slot-slotds extra)
X
X    (setf (class-named name) class)
X    name))
X
X(defmeth supers-changed ((class essential-class)
X             old-local-supers
X             old-local-slots
X             extra
X             top-p)
X  (ignore old-local-supers old-local-slots top-p)
X  (let ((cpl (compute-class-precedence-list class)))
X    (setf (class-class-precedence-list class) cpl)
X;   (update-slots--class class cpl)                 ;This is NOT part of
X;                                 ;the essential-class
X;                                 ;protocol.
X    (dolist (sub-class (class-direct-subclasses class))
X      (supers-changed sub-class
X              (class-local-supers sub-class)
X              (class-local-slots sub-class)
X              extra
X              nil))
X;   (when top-p                                          ;This is NOT part of
X;     (update-method-inheritance class old-local-supers));the essential-class
X;                                      ;protocol.
X    ))
X
X(defmeth slots-changed ((class essential-class)
X            old-local-slots
X            extra
X            top-p)
X  (ignore top-p old-local-slots)
X  ;; When this is called, class should have its local-supers and
X  ;; local-slots slots filled in properly.
X; (update-slots--class class (class-class-precedence-list class))
X  (dolist (sub-class (class-direct-subclasses class))
X    (slots-changed sub-class (class-local-slots sub-class) extra nil)))
X
X(defmeth method-equal (method argument-specifiers options)
X  (ignore options)
X  (equal argument-specifiers (method-type-specifiers method)))
X
X(defmeth methods-combine-p ((d essential-discriminator))
X  (ignore d)
X  nil)
X
X)
X
X  ;;
X;;;;;;
X  ;;
X
X(define-method-body-macro call-next-method ()
X  :global :error
X  :method (expand-call-next-method
X        (macroexpand-time-method macroexpand-time-environment)
X        nil
X        macroexpand-time-environment))
X
X(defmethod expand-call-next-method ((mex-method method) args mti)
X  (ignore args)
X  (let* ((arglist (and mex-method (method-arglist mex-method)))
X     (uid (macroexpand-time-method-uid mti))
X     (load-method-1-args (macroexpand-time-load-method-1-args mti))
X     (load-time-eval-form `(load-time-eval
X                 (if (boundp ',uid)
X                     ,uid
X                     (setq ,uid
X                       (apply #'load-method-1
X                          ',load-method-1-args)))))
X     (applyp nil))
X    (multiple-value-setq (arglist applyp) (make-call-arguments arglist))
X    (cond ((null (method-type-specifiers mex-method))
X       (warn "Using call-next-method in a default method.~%~
X                  At run time this will generate an error.")
X       '(error "Using call-next-method in a default method."))
X      (applyp
X       `(apply
X          #'call-next-method-internal ,load-time-eval-form . ,arglist))
X      (t
X       `(call-next-method-internal ,load-time-eval-form . ,arglist)))))
X
X(defun call-next-method-internal (current-method &rest args)
X  (let* ((discriminator (method-discriminator current-method))
X     (type-specifiers (method-type-specifiers current-method))
X     (most-specific nil)
X     (most-specific-type-specifiers ())
X     (dispatch-order (get-slot--class discriminator 'dispatch-order)))
X    (iterate ((method in (discriminator-methods discriminator)))
X      (let ((method-type-specifiers (method-type-specifiers method))
X            (temp ()))
X        (and (every #'(lambda (arg type-spec)
X            (or (eq type-spec 't)
X                (memq type-spec
X                  (get-slot--class
X                    (class-of arg) 'class-precedence-list))))
X                    args method-type-specifiers)
X             (eql 1 (setq temp (compare-type-specifier-lists
X                 type-specifiers
X                 method-type-specifiers
X                 ()
X                 args
X                 ()
X                 dispatch-order)))
X             (or (null most-specific)
X                 (eql 1 (setq temp (compare-type-specifier-lists
X                                     method-type-specifiers
X                                     most-specific-type-specifiers
X                                     ()
X                                     args
X                                     ()
X                     dispatch-order))))
X             (setq most-specific method
X                   most-specific-type-specifiers method-type-specifiers))))
X    (if (or most-specific
X            (setq most-specific (discriminator-default-method
X                  discriminator)))
X        (apply (method-function most-specific) args)
X        (error "no super method found"))))
X
X;;;
X;;; This is kind of bozoid because it always copies the lambda-list even
X;;; when it doesn't need to.  It also doesn't remember things it could
X;;; remember, causing it to call memq more than it should.  Fix this one
X;;; day when there is nothing else to do.
X;;;
X(defun make-call-arguments (lambda-list &aux applyp)
X  (setq lambda-list (reverse lambda-list))
X  (when (memq '&aux lambda-list)
X    (setq lambda-list (cdr (memq '&aux lambda-list))))
X  (setq lambda-list (nreverse lambda-list))
X  (let ((optional (memq '&optional lambda-list)))
X    (when optional
X      ;; The &optional keyword appears in the lambda list.
X      ;; Get rid of it, by moving the rest of the lambda list
X      ;; up, then go through the optional arguments, replacing
X      ;; them with the real symbol.
X      (setf (car optional) (cadr optional)
X        (cdr optional) (cddr optional))
X      (iterate ((loc on optional))
X    (when (memq (car loc) lambda-list-keywords)
X      (unless (memq (car loc) '(&rest &key &allow-other-keys))
X        (error
X          "The non-standard lambda list keyword ~S appeared in the~%~
X               lambda list of a method in which CALL-NEXT-METHOD is used.~%~
X               PCL can only deal with standard lambda list keywords."))
X      (when (listp (car loc)) (setf (car loc) (caar loc)))))))
X  (let ((rest (memq '&rest lambda-list)))
X    (cond ((not (null rest))
X       ;; &rest appears in the lambda list. This means we
X       ;; have to do an apply. We ignore the rest of the
X       ;; lambda list, just grab the &rest var and set applyp.
X       (setf (car rest) (if (listp (cadr rest))
X                (caadr rest)
X                (cadr rest))
X         (cdr rest) ())
X       (setq applyp t))
X      (t
X       (let ((key (memq '&key lambda-list)))
X         (when key
X           ;; &key appears in the lambda list.  Remove &key from the
X           ;; lambda list then replace all the keywords with pairs of
X           ;; the actual keyword followed by the value variable.
X           ;; Have to parse the hairy triple case of &key.
X           (let ((key-args
X               (iterate ((arg in (cdr key)))
X             (until (eq arg '&allow-other-keys))
X             (cond ((symbolp arg)
X                (collect (make-keyword arg))
X                (collect arg))
X                   ((cddr arg)
X                (collect (caddr arg))
X                (collect (car arg)))
X                   (t
X                (collect (make-keyword (car arg)))
X                (collect (car arg)))))))
X         (if key-args
X             (setf (car key) (car key-args)
X               (cdr key) (cdr key-args))
X             (setf (cdr key) nil
X               lambda-list (remove '&key lambda-list)))))))))
X  (values lambda-list applyp))
X
END_OF_FILE
if test 12761 -ne `wc -c <'fixup.l'`; then
    echo shar: \"'fixup.l'\" unpacked with wrong size!
fi
# end of 'fixup.l'
fi
if test -f 'high.l' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'high.l'\"
else
echo shar: Extracting \"'high.l'\" \(9615 characters\)
sed "s/^X//" >'high.l' <<'END_OF_FILE'
X;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
X;;;
X;;; *************************************************************************
X;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
X;;;
X;;; Use and copying of this software and preparation of derivative works
X;;; based upon this software are permitted.  Any distribution of this
X;;; software or derivative works must comply with all applicable United
X;;; States export control laws.
X;;;
X;;; This software is made available AS IS, and Xerox Corporation makes no
X;;; warranty about the software, its performance or its conformity to any
X;;; specification.
X;;;
X;;; Any person obtaining a copy of this software is requested to send their
X;;; name and post office or electronic mail address to:
X;;;   CommonLoops Coordinator
X;;;   Xerox Artifical Intelligence Systems
X;;;   2400 Hanover St.
X;;;   Palo Alto, CA 94303
X;;; (or send Arpanet mail to [e-mail])
X;;;
X;;; Suggestions, comments and requests for improvements are also welcome.
X;;; *************************************************************************
X;;;
X;;; Non-Bootstrap stuff
X;;;
X
X(in-package 'pcl :nicknames '(portable-commonloops))
X
X
X(ndefstruct (obsolete-class (:class class)
X                            (:include (class))))
X
X
X(defmeth get-slot-using-class ((class obsolete-class)
X                   object slot-name
X                   dont-call-slot-missing-p
X                   default)
X  (change-class object
X        (cadr (get-slot class 'class-precedence-list)))
X  (get-slot-using-class
X    (class-of object) object slot-name dont-call-slot-missing-p default))
X
X
X  ;;
X;;;;;;
X  ;;
X
X
X(defmeth describe-class (class-or-class-name
X              &optional (stream *standard-output*))
X  (flet ((pretty-class (class) (or (class-name class) class)))
X    (if (symbolp class-or-class-name)
X    (describe-class (class-named class-or-class-name) stream)
X    (let ((class class-or-class-name))
X      (format stream
X          "~&The class ~S is an instance of class ~S."
X          class
X          (class-of class))
X      (format stream "~&Name:~23T~S~%~
X                Class-Precedence-List:~23T~S~%~
X                            Local-Supers:~23T~S~%~
X                            Direct-Subclasses:~23T~S"
X          (class-name class)
X          (mapcar #'pretty-class (class-class-precedence-list class))
X          (mapcar #'pretty-class (class-local-supers class))
X          (mapcar #'pretty-class (class-direct-subclasses class)))
X      class))))
X
X(defun describe-instance (object &optional (stream t))
X  (let* ((class (class-of object))
X         (instance-slots (class-instance-slots class))
X         (non-instance-slots (class-non-instance-slots class))
X         (dynamic-slots (iwmc-class-dynamic-slots object))
X     (max-slot-name-length 0))
X    (macrolet ((adjust-slot-name-length (name)
X         `(setq max-slot-name-length
X            (max max-slot-name-length
X                 (length (the string (symbol-name ,name))))))
X           (describe-slot (name value &optional (allocation () alloc-p))
X         (if alloc-p
X             `(format stream
X                  "~% ~A ~S ~VT  ~S"
X                  ,name ,allocation (+ max-slot-name-length 7)
X                  ,value)
X             `(format stream
X                  "~% ~A~VT  ~S"
X                  ,name max-slot-name-length ,value))))
X      ;; Figure out a good width for the slot-name column.
X      (iterate ((slotd in instance-slots))
X    (adjust-slot-name-length (slotd-name slotd)))
X      (iterate ((slotd in non-instance-slots))
X    (adjust-slot-name-length (slotd-name slotd)))
X      (iterate ((name in dynamic-slots by cddr))
X    (adjust-slot-name-length name))
X      (setq max-slot-name-length  (min (+ max-slot-name-length 3) 30))
X      (format stream "~%~S is an instance of class ~S:" object class)
X      (format stream "~% The following slots are allocated in the instance ~
X                         (:INSTANCE allocation):")
X      (iterate ((slotd in instance-slots))
X    (let ((name (slotd-name slotd)))
X      (describe-slot name (get-slot object name))))
X      (when (or dynamic-slots
X        (iterate ((slotd in non-instance-slots))
X          (when (neq (slotd-allocation slotd) :dynamic) (return t))))
X    (format stream
X        "~%The following slots have special allocations as shown:")
X    (iterate ((slotd in non-instance-slots))
X      (unless (eq (slotd-allocation slotd) :dynamic)
X        (describe-slot (slotd-name slotd)
X               (get-slot object (slotd-name slotd))
X               (slotd-allocation slotd))))
X    (iterate ((name in dynamic-slots by cddr)
X          (val in (cdr dynamic-slots) by cddr))
X      (describe-slot name val :dynamic)))))
X  object)
X
X
X  ;;
X;;;;;;
X  ;;
X
X(ndefstruct (structure-metaclass (:class class)
X                 (:include class)
X                 (:constructor nil)))
X
X(defmeth expand-defstruct ((class structure-metaclass)
X               name-and-options doc slot-descriptions)
X  (ignore class doc)
X  (let ((class-argument (iterate ((option in (cdr name-and-options)))
X                 (when (and (listp option)
X                        (eq (car option) ':class))
X                   (return option)))))
X    `(defstruct ,(remove class-argument name-and-options)
X       . ,slot-descriptions)))
X
X
X  ;;
X;;;;;;
X  ;;
X
X(eval-when (compile load eval)
X(ndefstruct (built-in (:class class)
X              (:include (class))))
X
X(ndefstruct (built-in-with-fast-type-predicate (:class class)
X                           (:include (built-in))))
X
X(defmacro define-built-in-class (name includes &optional fast-type-predicate)
X  `(ndefstruct (,name (:class ,(if fast-type-predicate
X                   'built-in-with-fast-type-predicate
X                   'built-in))
X              (:include ,includes))
X     (fast-type-predicate ',fast-type-predicate)  ;;;
X
X     ))
X
X(defmeth parse-defstruct-options ((class built-in) name options)
X  (let ((ds-options (call-next-method)))
X    (or (ds-options-includes ds-options)
X    (setf (ds-options-includes ds-options) (list 'object)))
X    ds-options))
X
X(defmeth expand-defstruct-make-definitions ((class built-in)
X                        name ds-options slotds)
X  (ignore class name ds-options slotds)
X  ())
X
X(defmeth make-instance ((class built-in))
X  (ignore class)
X  (error
X    "Attempt to make an instance of the built-in class ~S.~%~
X     Currently it is not possible to make instance of built-in classes with~
X     make.~%~
X     A design for this exists, because of metaclasses it is easy to do,~%~
X     it just has to be done."
X    class))
X
X(defmeth compatible-meta-class-change-p
X     ((from built-in)
X      (to built-in-with-fast-type-predicate))
X  (ignore from to)
X  t)
X
X(defmeth check-super-metaclass-compatibility ((built-in built-in)
X                           (new-super class))
X  (or (eq new-super (class-named 't))
X      (error "~S cannot have ~S as a super.~%~
X              The only meta-class CLASS class that a built-in class can~%~
X              have as a super is the class T."
X         built-in new-super)))
X
X
X
X(defmeth check-super-metaclass-compatibility
X     ((class built-in)
X      (new-local-super built-in))
X  (ignore class new-local-super)
X  t)
X
X;(defmeth check-super-metaclass-compatibility
X;     ((class built-in-with-fast-type-predicate)
X;      (new-local-super built-in))
X;  (ignore class new-local-super)
X;  t)
X
X(defmeth compute-class-precedence-list ((class built-in))
X  ;; Compute the class-precedence list just like we do for CLASS except that
X  ;; a built-in class cannot inherit COMMON from another built-in class.  But
X  ;; it does inherit the things that it would have inherited had it inherited
X  ;; common.
X  (let ((val (call-next-method))
X    (common-class nil))
X    (if (not (memq (setq common-class (class-named 'common t))
X           (class-local-supers class)))
X    (remove common-class val)
X    val)))
X
X
X)
X
X  ;;
X;;;;;; The built in types
X  ;;
X
X(define-built-in-class common (t))
X
X(define-built-in-class pathname (common) pathnamep)
X
X(define-built-in-class stream (common) streamp)
X
X(define-built-in-class sequence (t))
X(define-built-in-class list (sequence) listp)
X(define-built-in-class cons (list common) consp)
X(define-built-in-class symbol (common) symbolp)
X(define-built-in-class null (list symbol) null)
X
X(define-built-in-class keyword (symbol common) keywordp)
X
X(define-built-in-class array (common) arrayp)
X(define-built-in-class vector (sequence array) vectorp)
X(define-built-in-class simple-array (array))
X
X(define-built-in-class string (vector common) stringp)
X(define-built-in-class bit-vector (vector) bit-vector-p)
X;(vector t) should go here
X
X(define-built-in-class simple-string (string simple-array) simple-string-p)
X(define-built-in-class simple-bit-vector (bit-vector simple-array)
X                     simple-bit-vector-p)
X(define-built-in-class simple-vector (vector simple-array) simple-vector-p)
X
X(define-built-in-class function (t))
X
X(define-built-in-class character (t) characterp)
X(define-built-in-class string-char (character) string-char-p)
X(define-built-in-class standard-char (string-char common) standard-char-p)
X
X(define-built-in-class structure (common))
X
X(define-built-in-class number (t) numberp)
X
X(define-built-in-class rational (number) rationalp)
X(define-built-in-class float (number) floatp)
X(define-built-in-class complex (number common) complexp)
X
X(define-built-in-class integer (rational))
X(define-built-in-class ratio   (rational common))
X
X(define-built-in-class fixnum (integer common))
X(define-built-in-class bignum (integer common))
X
X(define-built-in-class short-float  (float common))
X(define-built-in-class single-float (float common))
X(define-built-in-class double-float (float common))
X(define-built-in-class long-float   (float common))
X
X(define-built-in-class hash-table (common) hash-table-p)
X(define-built-in-class readtable (common) readtablep)
X(define-built-in-class package (common) packagep)
X(define-built-in-class random-state (common) random-state-p)
X
X
X(eval-when (load)
X  (setq *error-when-defining-method-on-existing-function* t))
X
END_OF_FILE
if test 9615 -ne `wc -c <'high.l'`; then
    echo shar: \"'high.l'\" unpacked with wrong size!
fi
# end of 'high.l'
fi
echo shar: End of archive 3 \(of 13\).
cp /dev/null ark3isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 13 archives.
    rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
    echo You still need to unpack the following archives:
    echo "        " ${MISSING}
fi
##  End of shell archive.
exit 0
--

Rich $alz            "Anger is an energy"
Cronus Project, BBN Labs    [e-mail]
Moderator, comp.sources.unix    [e-mail]